home *** CD-ROM | disk | FTP | other *** search
/ Usenet 1993 July / InfoMagic USENET CD-ROM July 1993.ISO / sources / unix / volume10 / ifp / part04 < prev    next >
Encoding:
Internet Message Format  |  1987-07-05  |  41.8 KB
  1. Path: uunet!rs
  2. From: rs@uunet.UU.NET (Rich Salz)
  3. Newsgroups: comp.sources.unix
  4. Subject: v10i037: Interpreted Functional Programming lanuage, Part 04/07
  5. Message-ID: <574@uunet.UU.NET>
  6. Date: 7 Jul 87 04:32:09 GMT
  7. Organization: UUNET Communications Services, Arlington, VA
  8. Lines: 1409
  9. Approved: rs@uunet.uu.net
  10.  
  11. Mod.sources: Volume 10, Number 37
  12. Submitted by: robison@b.cs.uiuc.edu (Arch Robison)
  13. Archive-name: ifp/Part04
  14.  
  15. #! /bin/sh
  16. # This is a shell archive, meaning:
  17. # 1. Remove everything above the #! /bin/sh line.
  18. # 2. Save the resulting text in a file.
  19. # 3. Execute the file with /bin/sh.
  20. # The following files will be created:
  21. #    interp/G_confont.c
  22. #    interp/G_draw.c
  23. #    interp/Makefile
  24. #    interp/README
  25. #    interp/alloc.c
  26. #    interp/apply.c
  27. #    interp/binio.c
  28. export PATH; PATH=/bin:$PATH
  29. mkdir interp
  30. if test -f 'interp/G_confont.c'
  31. then
  32.     echo shar: over-writing existing file "'interp/G_confont.c'"
  33. fi
  34. cat << \SHAR_EOF > 'interp/G_confont.c'
  35.  
  36. /* Written 12:01 pm  Jan  8, 1985 by gwyn@brl-tgr in uiucdcsb:net.unix */
  37. /*
  38.     symbol -- software character generator subroutine
  39.  
  40.     last edit:    26-Nov-1984    D A Gwyn
  41.             18-Mar-1985     A D Robison - hacked for GSI card
  42.                               rehacked for console
  43.  
  44. Function:
  45.  
  46.     This routine plots an ASCII character string as vector strokes.
  47.  
  48.  
  49. Calling sequence:
  50.  
  51.     void ConSymbol (
  52.              char *string,       // -> NUL-terminated string
  53.              int transform [2][3]; // text transformation //
  54.            );
  55.  
  56. The characters are on a 6 high by 4 wide grid.  The transform is scaled
  57. by 1024 and transforms from the character grid onto console device coordinates.
  58. E.g. the unit transform is {{1024,0,0},{0,1024,0}}.
  59.  
  60. */
  61.  
  62. /*
  63.                 STROKE TABLES
  64.  
  65.     The stroke[] table contains encodings for all vector strokes
  66.     needed to draw each character at a standard size.  Actual plot
  67.     output is of course properly positioned, scaled, and rotated.
  68.     To keep code size small, variable-length entries are used; each
  69.     character stroke sequence is terminated by a 0 datum.  Pointers
  70.     to the appropriate data for every character is stored into
  71.     sstroke[] during a one-time initialization.
  72.  
  73.     The prototypes are constrained to a 4 x 6 unit area, except for
  74.     occasional descenders up to 2 units below the baseline.  All
  75.     visible strokes should be "basic" vectors (in directions that
  76.     are integral multiples of 45 degrees) for best overall results
  77.     on most devices, especially with small character height.  The
  78.     first 16 "control" characters are plotted as non-standard extra
  79.     symbols, the next 16 produce Calcomp "centered plotting symbols"
  80.     (not centered here!), and the final 96 characters are plotted as
  81.     corresponding ASCII graphics (DEL plots as a grid).
  82.  
  83.     A prototype stroke is encoded as 8 bits SVXXXYYY:
  84.         S    = 0 if YYY is correct as is
  85.               1 if YYY needs to have 2 subtracted
  86.         V    = 0 if stroke is invisible (move)
  87.               1 if stroke is visible (draw)
  88.         XXX    = final X coord of stroke (0..4)
  89.         YYY    = final Y coord of stroke (0..6)
  90. */
  91.  
  92. /* bit masks for fields in stroke vector */
  93.  
  94. #define    S    0200
  95. #define    V    0100
  96. #define    XXX    0070
  97. #define    YYY    0007
  98.  
  99. #define    XJUST    3            /* bits to the right of XXX */
  100.  
  101. /* stroke vectors for all characters */
  102.  
  103. static char    stroke[] =
  104.     {
  105. /*NUL*/    0003, 0105, 0123, 0143, 0141, 0121, 0125, 0,
  106. /*SOH*/    0006, 0115, 0112, 0142, 0022, 0121, 0141, 0140, 0120, 0013,
  107.     0133, 0034, 0114, 0015, 0126, 0,
  108. /*STX*/    0021, 0125, 0105, 0103, 0123, 0141, 0143, 0,
  109. /*ETX*/    0012, 0114, 0034, 0104, 0106, 0126, 0124, 0033, 0113, 0021,
  110.     0141, 0042, 0122, 0120, 0,
  111. /*EOT*/    0005, 0125, 0134, 0145, 0143, 0023, 0125, 0015, 0113, 0,
  112. /*ENQ*/    0011, 0131, 0142, 0144, 0135, 0115, 0104, 0102, 0111, 0012,
  113.     0114, 0134, 0133, 0113, 0023, 0132, 0,
  114. /*ACK*/    0011, 0131, 0142, 0144, 0135, 0115, 0104, 0102, 0111, 0034,
  115.     0114, 0112, 0132, 0,
  116. /*BEL*/    0021, 0122, 0142, 0133, 0134, 0124, 0125, 0024, 0114, 0113,
  117.     0102, 0122, 0,
  118. /*BS */    0012, 0103, 0114, 0003, 0143, 0,
  119. /*HT */    0003, 0143, 0034, 0143, 0132, 0,
  120. /*LF */    0012, 0121, 0132, 0021, 0125, 0,
  121. /*VT */    0021, 0125, 0014, 0125, 0134, 0,
  122. /*FF */    0012, 0121, 0132, 0021, 0125, 0014, 0125, 0134, 0,
  123. /*CR */    0012, 0103, 0114, 0003, 0143, 0034, 0143, 0132, 0,
  124. /*SO */    0004, 0124, 0126, 0106, 0104, 0014, 0112, 0142, 0034, 0130, 0,
  125. /*SI */    0021, 0123, 0013, 0115, 0025, 0105, 0003, 0123, 0141, 0143, 0,
  126. /*DLE*/    0023, 0125, 0145, 0141, 0101, 0105, 0125, 0,
  127. /*DC1*/    0023, 0125, 0135, 0144, 0142, 0131, 0111, 0102, 0104, 0115,
  128.     0125, 0,
  129. /*DC2*/    0023, 0124, 0142, 0102, 0124, 0,
  130. /*DC3*/    0021, 0125, 0003, 0143, 0,
  131. /*DC4*/    0001, 0145, 0005, 0141, 0,
  132. /*NAK*/    0023, 0125, 0143, 0121, 0103, 0125, 0,
  133. /*SYN*/    0021, 0125, 0143, 0103, 0125, 0,
  134. /*ETB*/    0001, 0145, 0105, 0141, 0,
  135. /*CAN*/    0005, 0145, 0101, 0141, 0,
  136. /*EM */    0023, 0121, 0005, 0123, 0145, 0,
  137. /*SUB*/    0023, 0145, 0034, 0132, 0141, 0032, 0112, 0101, 0012, 0114,
  138.     0105, 0014, 0134, 0,
  139. /*ESC*/    0001, 0145, 0025, 0121, 0041, 0105, 0003, 0143, 0,
  140. /*FS */    0001, 0141, 0105, 0145, 0101, 0,
  141. /*GS */    0021, 0125, 0,
  142. /*RS */    0023, 0125, 0024, 0142, 0102, 0124, 0021, 0122, 0144, 0104,
  143.     0122, 0,
  144. /*US */    0023, 0143, 0,
  145. /*SP */    0,
  146. /* ! */    0020, 0121, 0022, 0126, 0,
  147. /* " */    0014, 0116, 0036, 0134, 0,
  148. /* # */    0010, 0116, 0036, 0130, 0042, 0102, 0004, 0144, 0,
  149. /* $ */    0002, 0111, 0131, 0142, 0133, 0113, 0104, 0115, 0135, 0144,
  150.     0026, 0120, 0,
  151. /* % */    0001, 0145, 0025, 0114, 0105, 0116, 0125, 0032, 0141, 0130,
  152.     0121, 0132, 0,
  153. /* & */    0040, 0104, 0105, 0116, 0125, 0124, 0102, 0101, 0110, 0120,
  154.     0142, 0,
  155. /* ' */    0014, 0136, 0,
  156. /* ( */    0030, 0112, 0114, 0136, 0,
  157. /* ) */    0010, 0132, 0134, 0116, 0,
  158. /* * */    0001, 0145, 0025, 0121, 0041, 0105, 0,
  159. /* + */    0021, 0125, 0003, 0143, 0,
  160. /* , */    0211, 0120, 0121, 0,
  161. /* - */    0003, 0143, 0,
  162. /* . */    0020, 0121, 0,
  163. /* / */    0001, 0145, 0,
  164. /* 0 */    0001, 0145, 0136, 0116, 0105, 0101, 0110, 0130, 0141, 0145, 0,
  165. /* 1 */    0010, 0130, 0020, 0126, 0115, 0,
  166. /* 2 */    0005, 0116, 0136, 0145, 0144, 0100, 0140, 0,
  167. /* 3 */    0001, 0110, 0130, 0141, 0142, 0133, 0144, 0145, 0136, 0116,
  168.     0105, 0023, 0133, 0,
  169. /* 4 */    0030, 0136, 0024, 0102, 0142, 0,
  170. /* 5 */    0001, 0110, 0130, 0141, 0143, 0134, 0114, 0103, 0106, 0146, 0,
  171. /* 6 */    0002, 0113, 0133, 0142, 0141, 0130, 0110, 0101, 0105, 0116,
  172.     0136, 0145, 0,
  173. /* 7 */    0006, 0146, 0145, 0112, 0110, 0,
  174. /* 8 */    0013, 0102, 0101, 0110, 0130, 0141, 0142, 0133, 0113, 0104,
  175.     0105, 0116, 0136, 0145, 0144, 0133, 0,
  176. /* 9 */    0001, 0110, 0130, 0141, 0145, 0136, 0116, 0105, 0104, 0113,
  177.     0133, 0144, 0,
  178. /* : */    0020, 0121, 0023, 0124, 0,
  179. /* ; */    0211, 0120, 0121, 0023, 0124, 0,
  180. /* < */    0030, 0103, 0136, 0,
  181. /* = */    0002, 0142, 0044, 0104, 0,
  182. /* > */    0010, 0143, 0116, 0,
  183. /* ? */    0005, 0116, 0136, 0145, 0144, 0122, 0021, 0120, 0,
  184. /* @ */    0031, 0133, 0124, 0113, 0112, 0121, 0131, 0142, 0144, 0135,
  185.     0115, 0104, 0101, 0110, 0130, 0,
  186. /* A */    0104, 0126, 0144, 0140, 0042, 0102, 0,
  187. /* B */    0130, 0141, 0142, 0133, 0144, 0145, 0136, 0106, 0100, 0003,
  188.     0133, 0,
  189. /* C */    0045, 0136, 0116, 0105, 0101, 0110, 0130, 0141, 0,
  190. /* D */    0130, 0141, 0145, 0136, 0106, 0100, 0,
  191. /* E */    0003, 0133, 0046, 0106, 0100, 0140, 0,
  192. /* F */    0106, 0146, 0033, 0103, 0,
  193. /* G */    0022, 0142, 0141, 0130, 0110, 0101, 0105, 0116, 0136, 0145, 0,
  194. /* H */    0106, 0046, 0140, 0043, 0103, 0,
  195. /* I */    0010, 0130, 0020, 0126, 0016, 0136, 0,
  196. /* J */    0001, 0110, 0130, 0141, 0146, 0,
  197. /* K */    0106, 0046, 0102, 0013, 0140, 0,
  198. /* L */    0006, 0100, 0140, 0,
  199. /* M */    0106, 0124, 0146, 0140, 0,
  200. /* N */    0106, 0005, 0141, 0040, 0146, 0,
  201. /* O */    0010, 0130, 0141, 0145, 0136, 0116, 0105, 0101, 0110, 0,
  202. /* P */    0106, 0136, 0145, 0144, 0133, 0103, 0,
  203. /* Q */    0010, 0130, 0141, 0145, 0136, 0116, 0105, 0101, 0110, 0022,
  204.     0140, 0,
  205. /* R */    0106, 0136, 0145, 0144, 0133, 0103, 0013, 0140, 0,
  206. /* S */    0001, 0110, 0130, 0141, 0142, 0133, 0113, 0104, 0105, 0116,
  207.     0136, 0145, 0,
  208. /* T */    0020, 0126, 0006, 0146, 0,
  209. /* U */    0006, 0101, 0110, 0130, 0141, 0146, 0,
  210. /* V */    0006, 0102, 0120, 0142, 0146, 0,
  211. /* W */    0006, 0100, 0122, 0140, 0146, 0,
  212. /* X */    0101, 0145, 0146, 0006, 0105, 0141, 0140, 0,
  213. /* Y */    0020, 0123, 0105, 0106, 0046, 0145, 0123, 0,
  214. /* Z */    0040, 0100, 0101, 0145, 0146, 0106, 0013, 0133, 0,
  215. /* [ */    0030, 0110, 0116, 0136, 0,
  216. /* \ */    0005, 0141, 0,
  217. /* ] */    0010, 0130, 0136, 0116, 0,
  218. /* ^ */    0004, 0126, 0144, 0,
  219. /* _ */    0201, 0341, 0,
  220. /* ` */    0016, 0134, 0,
  221. /* a */    0003, 0114, 0134, 0143, 0140, 0042, 0112, 0101, 0110, 0130,
  222.     0141, 0,
  223. /* b */    0106, 0001, 0110, 0130, 0141, 0143, 0134, 0114, 0103, 0,
  224. /* c */    0043, 0134, 0114, 0103, 0101, 0110, 0130, 0141, 0,
  225. /* d */    0043, 0134, 0114, 0103, 0101, 0110, 0130, 0141, 0040, 0146, 0,
  226. /* e */    0002, 0142, 0143, 0134, 0114, 0103, 0101, 0110, 0130, 0141, 0,
  227. /* f */    0010, 0115, 0126, 0136, 0145, 0034, 0104, 0,
  228. /* g */    0201, 0310, 0330, 0341, 0144, 0041, 0130, 0110, 0101, 0103,
  229.     0114, 0134, 0143, 0,
  230. /* h */    0106, 0003, 0114, 0134, 0143, 0140, 0,
  231. /* i */    0020, 0124, 0114, 0025, 0126, 0,
  232. /* j */    0201, 0310, 0330, 0341, 0144, 0045, 0146, 0,
  233. /* k */    0106, 0044, 0100, 0022, 0140, 0,
  234. /* l */    0020, 0126, 0116, 0,
  235. /* m */    0104, 0003, 0114, 0123, 0120, 0040, 0143, 0134, 0123, 0,
  236. /* n */    0104, 0003, 0114, 0134, 0143, 0140, 0,
  237. /* o */    0010, 0130, 0141, 0143, 0134, 0114, 0103, 0101, 0110, 0,
  238. /* p */    0001, 0110, 0130, 0141, 0143, 0134, 0114, 0103, 0004, 0300, 0,
  239. /* q */    0041, 0130, 0110, 0101, 0103, 0114, 0134, 0143, 0044, 0340, 0,
  240. /* r */    0104, 0003, 0114, 0134, 0143, 0,
  241. /* s */    0001, 0110, 0130, 0141, 0132, 0112, 0103, 0114, 0134, 0143, 0,
  242. /* t */    0004, 0134, 0015, 0111, 0120, 0130, 0141, 0,
  243. /* u */    0004, 0101, 0110, 0130, 0141, 0040, 0144, 0,
  244. /* v */    0004, 0102, 0120, 0142, 0144, 0,
  245. /* w */    0004, 0101, 0110, 0121, 0022, 0121, 0130, 0141, 0144, 0,
  246. /* x */    0144, 0004, 0140, 0,
  247. /* y */    0201, 0310, 0330, 0341, 0144, 0004, 0101, 0110, 0130, 0141, 0,
  248. /* z */    0004, 0144, 0100, 0140, 0,
  249. /* { */    0030, 0121, 0122, 0113, 0124, 0125, 0136, 0,
  250. /* | */    0020, 0126, 0,
  251. /* } */    0010, 0121, 0122, 0133, 0124, 0125, 0116, 0,
  252. /* ~ */    0005, 0116, 0134, 0145, 0,
  253. /*DEL*/    0140, 0146, 0106, 0100, 0010, 0116, 0026, 0120, 0030, 0136, 0
  254.     };
  255.  
  256. /* pointers to start of stroke data for each character */
  257.  
  258. static char    *sstroke[128] = {(char *) 0};
  259.  
  260.             /* CONSTANTS */
  261. #define    CHSPAC    6            /* prototype text spacing */
  262. #define    ASCMASK    0177            /* 7-bit ASCII mask */
  263. #define void int
  264.  
  265.             /* GLOBAL DATA */
  266.  
  267. static int (*T)[3];            /* text transformation */
  268.  
  269.             /* ENTRY POINT */
  270.  
  271. void ConSymbol (string,transform)
  272.    char *string;        /* -> NUL-terminated string */
  273.    int    transform[2][3];    /* text transformation */
  274.    {
  275.       register char *sp;    /* -> stroke data */
  276.       register int cornx;    /* proto X of cell corner */
  277.       register int c;            /* char from ASCII string    */
  278.                 /* also used for stroke data */
  279.  
  280.       /* initialize starting stroke pointers upon first entry only */
  281.  
  282.       if (!sstroke[0]) {
  283.      sp = stroke;
  284.      for (c = 0; c < 128; ++c) {
  285.         sstroke [c] = sp;              /* starts here */
  286.         while (*sp++) continue;          /* 0 terminates the data */
  287.      }
  288.       }
  289.  
  290.       T = transform;
  291.  
  292.       /* look up strokes for each character and plot them */
  293.  
  294.       for (cornx = 0; c = *string++; cornx += CHSPAC) {
  295.  
  296.      sp = sstroke [c & ASCMASK]; /* -> stroke data */
  297.  
  298.      plot (cornx,0,0,0);     /* get to character cell LLC */
  299.  
  300.      /* draw the strokes starting at LLC */
  301.  
  302.      while (c = *sp++ )    /* get stroke */
  303.         plot (cornx + ((c & XXX) >> XJUST),
  304.           (c & YYY) - ((c & S) ? 2 : 0),
  305.           (c & V),
  306.           (*sp & V));    /* move or draw */
  307.       }
  308.    }
  309.  
  310. /* transform prototype coordinates to actual plot coordinates */
  311. #define map(x,y,n) ((T[n][0] * x + T[n][1]*y + T[n][2]) + 512 >> 10);
  312.  
  313. static void plot (dx,dy,vis,NextVis)    /* plot adjusted stroke */
  314.    int dx,dy;                /* unrot pos rel to text LLC */
  315.    int vis;                    /* nonzero => visible */
  316.    int NextVis;                /* Is the next stroke visible? */
  317.    {
  318.       static int oldposx=0,oldposy=0;
  319.       static int olddx,olddy;
  320.       static int oldValid;
  321.       int posx,posy;
  322.  
  323.       if (vis && !oldValid) {
  324.      oldposx = map (olddx,olddy,0);
  325.      oldposy = map (olddx,olddy,1);
  326.      VI_AMove (oldposx,oldposy);
  327.       }
  328.       posx = map (dx,dy,0);
  329.       posy = map (dx,dy,1);
  330.  
  331.       /* no arithmetic overflow checking is done */
  332.  
  333.       if (vis) VI_RLine (posx-oldposx,posy-oldposy);
  334.  
  335.       oldValid = vis;
  336.       olddx = dx;
  337.       olddy = dy;
  338.       oldposx = posx;
  339.       oldposy = posy;
  340.    }
  341.  
  342. /* End of text from uiucdcsb:net.unix */
  343. SHAR_EOF
  344. if test -f 'interp/G_draw.c'
  345. then
  346.     echo shar: over-writing existing file "'interp/G_draw.c'"
  347. fi
  348. cat << \SHAR_EOF > 'interp/G_draw.c'
  349.  
  350. /****** G_draw.c ******************************************************/
  351. /**                                                                  **/
  352. /**                    University of Illinois                        **/
  353. /**                                                                  **/
  354. /**                Department of Computer Science                    **/
  355. /**                                                                  **/
  356. /**   Tool: IFP                  Version: 0.5             **/
  357. /**                                                                  **/
  358. /**   Author:  Arch D. Robison          Date:   May 1, 1985          **/
  359. /**                                                                  **/
  360. /**   Revised by: Arch D. Robison    Date: June 18, 1986         **/
  361. /**                                                                  **/
  362. /**   Principal Investigators: Prof. R. H. Campbell                  **/
  363. /**                            Prof. W. J. Kubitz                    **/
  364. /**                                                                  **/
  365. /**                                                                  **/
  366. /**------------------------------------------------------------------**/
  367. /**   (C) Copyright 1987  University of Illinois Board of Trustees   **/
  368. /**                       All Rights Reserved.                       **/
  369. /**********************************************************************/
  370.  
  371. /******************** FP Graphics Interface Module ********************/
  372.  
  373. /*
  374.  * The fp interpreter must be compiled with the -DGRAPHICS option to use
  375.  * the graphics interface.  The interface is specific to the PC/RT.
  376.  *
  377.  * There are no graphics primitives in FP itself, rather FP is used to
  378.  * calculate a display list.  The display list is then fed to DrawObject,
  379.  * which draws the picture specified by the display list.
  380.  *
  381.  * The display list has the following structure:
  382.  *
  383.  *     display-list == < {display-list} > | polyline | color | transform | text
  384.  *     polyline == < "line" { < x y > } >
  385.  *     color == < "color" color-index display-list >
  386.  *     text == <"text" print-atom size ["center"]>
  387.  *     transform = <"trans" t-matrix display-list >
  388.  *     t-matrix = <<Txx Txy Txo> <Tyx Tyy Tyo>>
  389.  *
  390.  * The polyline structure specifies a sequence of points.  Adjacent points
  391.  * are connected with line segments.
  392.  *
  393.  * The color structure draws the display-list in the color specified by
  394.  * the color index (0..15).  The color applies to all parts of the
  395.  * subordinate display-list which are not subordinate to a color structure
  396.  * within.  
  397.  *
  398.  * The transform structure draws the display-list as transformed by the
  399.  * t-matrix.  Transforms may be nested.
  400.  *
  401.  * The text structure draws a string with the lower-left corner at (0,0).
  402.  * Each character is drawn in a 1.0 by 1.0 box (including spacing).
  403.  */
  404.  
  405. #include <stdio.h>
  406. #include "struct.h"
  407. #include "string.h"
  408.  
  409. #define NKey 4
  410. StrPtr SKey[4],SCenter;
  411.  
  412. private short ScreenDim[2];
  413.  
  414. private void GraphError (InOut,Message)
  415.    ObjectPtr InOut;
  416.    char *Message;
  417.    {
  418.       VI_Term ();
  419.       printf ("%s\n",Message);
  420.       OutObject (InOut);
  421.       printf ("\n");
  422.       RepTag (InOut,BOTTOM);
  423.    }
  424.  
  425. void InitDraw ()
  426.    {
  427.       printf (" (RT/PC graphics)");
  428.       fflush (stdout);
  429.       SKey[0] = MakeString ("line");
  430.       SKey[1] = MakeString ("trans");
  431.       SKey[2] = MakeString ("color");
  432.       SKey[3] = MakeString ("text");
  433.       SCenter = MakeString ("center");
  434.    }
  435.  
  436. typedef double Transform [2][3];
  437.  
  438. Transform TransDefault = {
  439.    {800,0,0},
  440.    {0,800,0}
  441. };
  442.  
  443. forward void DrOb(), DrawText(), DrawTrans(), DrawColor (), PolyLine();
  444.  
  445. void DrawObject (InOut)
  446.    ObjectPtr InOut;
  447.    {
  448.       if (InOut->Tag == BOTTOM) return;
  449.  
  450.       VI_Init(ScreenDim,ScreenDim+1);
  451.       VI_Force();
  452.       VI_Color (0);
  453.       VI_Tile (ScreenDim[0],ScreenDim[1],1,1,"\0");
  454.       DrOb (InOut,TransDefault,1);
  455.       if (InOut->Tag != BOTTOM) {
  456.      while (getchar () != '\n') continue;
  457.      VI_Term ();
  458.       }
  459.    }
  460.  
  461. /*
  462.  * DrOb
  463.  *
  464.  * Draw object Inout with transform T and in color Color.
  465.  */
  466. private void DrOb (InOut,T,Color)
  467.    register ObjectPtr InOut;
  468.    Transform T;
  469.    int Color;
  470.    {
  471.       register int K;
  472.       register ListPtr P;
  473.  
  474.       if (InOut->Tag != LIST)
  475.      GraphError (InOut,"DrOb: invalid display object");
  476.       else {
  477.      P = InOut->List;
  478.      if (P == NULL || P->Val.Tag == LIST)
  479.         for (; P!=NULL; P=P->Next) DrOb (&P->Val,T,Color);
  480.      else if (P->Val.Tag != STRING)
  481.         GraphError (InOut,"DrOb: first element must be string");
  482.      else {
  483.         for (K=0; K<NKey; K++)
  484.            if (!StrComp (SKey [K],P->Val.String)) break;
  485.         switch (K) {
  486.            case 0:
  487.           PolyLine (P->Next,T,Color);
  488.           break;
  489.            case 1:
  490.           DrawTrans (P->Next,T,Color);
  491.           break;
  492.            case 2:
  493.           DrawColor (P->Next,T);
  494.           break;
  495.            case 3:
  496.           DrawText (P->Next,T,Color);
  497.           break;
  498.            default:
  499.           GraphError (InOut,"DrOb: unknown drawing command");
  500.           break;
  501.         }
  502.      }
  503.       }
  504.    }
  505.  
  506. private void GetCoor (P,T,X,Y)
  507.    register ListPtr P;
  508.    Transform T;
  509.    int *X,*Y;
  510.    {
  511.       extern short sddmul ();
  512.       register ListPtr Q;
  513.       double Xf,Yf;
  514.  
  515.       if (!PairTest (&P->Val,NUMERIC,NUMERIC))
  516.      GraphError (&P->Val,"GetCoor: numeric pair expected\n");
  517.       else {
  518.      Q = P->Val.List;
  519.      GetDouble (&Q->Val,&Xf);
  520.      GetDouble (&Q->Next->Val,&Yf);
  521.      *X = Xf * T[0][0] + Yf * T[0][1] + T[0][2];
  522.      *Y = Xf * T[1][0] + Yf * T[1][1] + T[1][2];
  523.       }
  524.    }
  525.  
  526. private void DrawText (P,T,Color)
  527.    register ListPtr P;
  528.    Transform T;
  529.    int Color;
  530.    {
  531.       char Buf[256];
  532.       CharPtr U;
  533.       int S[2][3];
  534.       int i,j,N3;
  535.       double Size;
  536.       boolean Center;
  537.  
  538.       if (P!=NULL) {
  539.      switch (P->Val.Tag) {
  540.         default: return;
  541.         case STRING:
  542.            CPInit (&U,&P->Val.List);
  543.            (void) CPRead (&U,Buf,256);
  544.            break;
  545.         case BOOLEAN:
  546.            (void) sprintf (Buf,P->Val.Bool ? "t" : "f");
  547.            break;
  548.         case INT:
  549.            (void) sprintf (Buf,"%ld",P->Val.Int);
  550.            break;
  551.         case FLOAT:
  552.            (void) sprintf (Buf,"%g",P->Val.Float);
  553.            break;
  554.      }
  555.      Size = 1.0;
  556.      Center = 0;
  557.      if (NULL != (P=P->Next)) {
  558.         GetDouble (&P->Val,&Size);
  559.     
  560.         if (NULL != (P=P->Next) && P->Val.Tag == STRING &&
  561.         !StrComp (P->Val.String,SCenter)) {
  562.            Center = 1;
  563.            N3 = 3*strlen (Buf);
  564.         }
  565.      }
  566.  
  567.      Size /= 6.0;
  568.  
  569.      for (i=0; i<2; i++)
  570.         for (j=0; j<3; j++)
  571.            S[i][j] = (int) ((j<2 ? Size * T[i][j] : T[i][j]) * (1 << 10));
  572.     
  573.      if (Center) {
  574.         S[0][2] -= N3 * S[0][0] + 3 * S[0][1];
  575.         S[1][2] -= N3 * S[1][0] + 3 * S[1][1];
  576.      }
  577.  
  578.      ConSymbol (Buf,S);
  579.       }
  580.    }
  581.  
  582. private void PolyLine (P,T,Color)
  583.    register ListPtr P;
  584.    Transform T;
  585.    int Color;
  586.    {
  587.       int X,Y;
  588.  
  589.       VI_Color (!Color);
  590.       if (P != NULL) {
  591.      GetCoor (P,T,&X,&Y);
  592.      VI_AMove (X,Y);
  593.      while (NULL != (P=P->Next)) {
  594.         GetCoor (P,T,&X,&Y);
  595.         VI_ALine (X,Y);
  596.      }
  597.       }
  598.    }
  599.  
  600. boolean GetTrans (X,T)
  601.    ObjectPtr X;
  602.    Transform T;
  603.    {
  604.       register ListPtr P,Q;
  605.       register int i,j;
  606.  
  607.       if (!PairTest (X,1<<LIST,1<<LIST)) return 0;
  608.       else {
  609.      P = X->List;
  610.      for (i=0; i<2; P=P->Next,i++) {
  611.         Q = P->Val.List;
  612.         for (j=0; j<3; Q=Q->Next,j++) {
  613.            if (Q == NULL) return 0;
  614.            if (GetDouble (&Q->Val,&T[i][j])) return 0;
  615.         }
  616.      }
  617.      return 1;
  618.       }
  619.    }
  620.  
  621. private void DrawTrans (P,T,Color)
  622.    register ListPtr P;
  623.    Transform T;
  624.    int Color;
  625.    {
  626.       Transform R,S;
  627.       int i,j;
  628.  
  629.       if (P!=NULL)
  630.      if (!GetTrans (&P->Val,R))
  631.         GraphError (&P->Val,"DrawTrans: not a transform");
  632.      else {
  633.         for (i=0; i<2; i++) {
  634.            for (j=0; j<3; j++)
  635.           S[i][j] = T[i][0] * R[0][j] + T[i][1] * R[1][j];
  636.            S[i][2] += T[i][2];
  637.         }
  638.      }
  639.      if (NULL != (P=P->Next)) DrOb (&P->Val,S,Color);
  640.    }
  641.  
  642. private void DrawColor (P,T)
  643.    register ListPtr P;
  644.    Transform T;
  645.    {
  646.       int Color;
  647.  
  648.       if (P!=NULL) {
  649.      switch (P->Val.Tag) {
  650.         case INT:
  651.            Color = P->Val.Int;
  652.            break;
  653.         case FLOAT:
  654.            Color = (int) (P->Val.Float + 0.5);
  655.            break;
  656.         default:
  657.            GraphError (&P->Val,"DrawColor: not a color");
  658.      }
  659.      if (P->Next != NULL) DrOb (&P->Next->Val,T,Color);
  660.       }
  661.    }
  662.  
  663. /***************************** end of G_draw.c *******************************/
  664.  
  665. SHAR_EOF
  666. if test -f 'interp/Makefile'
  667. then
  668.     echo shar: over-writing existing file "'interp/Makefile'"
  669. fi
  670. cat << \SHAR_EOF > 'interp/Makefile'
  671. #
  672. #****** Makefile ******************************************************#
  673. #**                                                                  **#
  674. #**                    University of Illinois                        **#
  675. #**                                                                  **#
  676. #**                Department of Computer Science                    **#
  677. #**                                                                  **#
  678. #**   Tool: IFP                  Version: 0.5             **#
  679. #**                                                                  **#
  680. #**   Author:  Arch D. Robison          Date:   May 1, 1985          **#
  681. #**                                                                  **#
  682. #**   Revised by: Arch D. Robison    Date:   Dec 5, 1986         **#
  683. #**                                                                  **#
  684. #**   Principal Investigators: Prof. R. H. Campbell                  **#
  685. #**                            Prof. W. J. Kubitz                    **#
  686. #**                                                                  **#
  687. #**                                                                  **#
  688. #**------------------------------------------------------------------**#
  689. #**   (C) Copyright 1987  University of Illinois Board of Trustees   **#
  690. #**                       All Rights Reserved.                       **#
  691. #**********************************************************************#
  692.  
  693. # makefile for ifp interpreter
  694. #
  695. # This makefile is set up for compiling the IFP interpreter on plain
  696. # vanilla UNIX boxes.  It has been tested on VAXen, Pyramids, and RT/PCs.  
  697. #
  698. # Other machines may required modifications to both this Makefile and
  699. # the header file struct.h.  You should first look at the beginning of
  700. # struct.h, which contains the machine-dependent preprocessor variables.
  701.  
  702. # for VAXen, Pyramids, RT/PC and other plain vanilla UNIX boxes.
  703. CFLAGS= -O
  704.  
  705. # Definitions for cross-compiling a MS-DOS version of IFP with the
  706. # XENIX system on a PC/AT.  The OPSYS variable in struct.h must
  707. # also be changed from UNIX to MSDOS.
  708. #AOBJS=dos.o
  709. #CFLAGS= -Ml -DPCAT -K -O -dos -F 24000 
  710. #LFLAGS= -DPCAT
  711.  
  712. # Definitions for compiling a XENIX version of IFP on a PC/AT.
  713. #CFLAGS= -DPCAT -Ml -O 
  714. #LFLAGS= -DPCAT           
  715.  
  716. # Definitions are for compiling IFP on a CRAY X-MP under CTSS
  717. #CFLAGS = 
  718.  
  719. # Definitions RT/PC with graphics
  720. #CFLAGS= -DCOMPILE -DGRAPHICS 
  721. #LFLAGS= -DCOMPILE -DGRAPHICS
  722. #GSRC = G_draw.c G_confont.c
  723. #GOBJS=    G_draw.o G_confont.o
  724. #LIBS= -laed
  725.  
  726. #------------------------------------------------------------------------------
  727.  
  728. IHDRS=    cache.h inob.h node.h stats.h string.h struct.h umax.h
  729.  
  730. ISRC=   F_arith.c F_pred.c F_misc.c F_seq.c F_ss.c F_subseq.c F_string.c\
  731.     alloc.c apply.c binio.c cache.c convert.c command.c debug.c\
  732.      error.c except.c file.c forms.c infun.c inimport.c inob.c list.c\
  733.     main.c node.c outfun.c outob.c stats.c string.c trace.c\
  734.     xdef.c
  735.  
  736. #     Miscellaneous source files for special versions of interpreter
  737. VSRC=   dos.s G_draw.c G_confont.c
  738.  
  739. IOBJS=  F_arith.o F_pred.o F_misc.o F_seq.o F_ss.o F_subseq.o F_string.o \
  740.     alloc.o apply.o binio.o cache.o convert.o command.o debug.o \
  741.     error.o except.o file.o forms.o infun.o inimport.o inob.o list.o \
  742.     main.o node.o outfun.o outob.o stats.o string.o trace.o \
  743.     xdef.o
  744.  
  745. #-----------------------------------------------------------------------------
  746.  
  747. ifp:    $(IOBJS) $(AOBJS) $(GOBJS)
  748.     cc $(CFLAGS) $(AOBJS) $(GOBJS) $(IOBJS) $(LIBS) -lm -o ifp
  749. #    strip ifp
  750.     echo "ifp recompiled"
  751.  
  752. $(IOBJS):    struct.h
  753.  
  754. G_confont.o:    G_confont.c            #console vector font
  755. G_draw.o:    struct.h G_draw.c        #optional graphics
  756.  
  757. F_misc.o:    node.h F_misc.c          #F_* = primitive functions
  758. F_string.o:    node.h
  759.  
  760. alloc.o:    node.h umax.h
  761. apply.o:    cache.h node.h stats.h 
  762. cache.o:    cache.h
  763. command.o:    cache.h inob.h node.h stats.h umax.h
  764. error.o:    inob.h
  765. file.o:        inob.h node.h umax.h
  766. forms.o:    node.h stats.h umax.h
  767. infun.o:    inob.h node.h
  768. inimport.o:    inob.h node.h 
  769. inob.o:        inob.h node.h
  770. list.o:        node.h stats.h umax.h 
  771. main.o:        cache.h stats.h umax.h
  772. node.o:        node.h umax.h
  773. outfun.o:    string.h node.h
  774. outob.o:    string.h 
  775. stats.o:    stats.h
  776. string.o:    string.h umax.h
  777. xdef.o:        node.h
  778.  
  779. #------------------------------------------------------------------------------
  780.  
  781. lint:      $(IHDRS) $(ISRC) $(GSRC)
  782.        lint -u -h $(LFLAGS) $(ISRC) $(GSRC) >lint.err
  783.  
  784. dos:       ifp
  785.        doscp -r ifp A:/ifp.exe
  786.  
  787. SHAR_EOF
  788. if test -f 'interp/README'
  789. then
  790.     echo shar: over-writing existing file "'interp/README'"
  791. fi
  792. cat << \SHAR_EOF > 'interp/README'
  793. See the Makefile for how to compile IFP.
  794. SHAR_EOF
  795. if test -f 'interp/alloc.c'
  796. then
  797.     echo shar: over-writing existing file "'interp/alloc.c'"
  798. fi
  799. cat << \SHAR_EOF > 'interp/alloc.c'
  800.  
  801. /****** alloc.c *******************************************************/
  802. /**                                                                  **/
  803. /**                    University of Illinois                        **/
  804. /**                                                                  **/
  805. /**                Department of Computer Science                    **/
  806. /**                                                                  **/
  807. /**   Tool: IFP                         Version: 0.5                 **/
  808. /**                                                                  **/
  809. /**   Author:  Arch D. Robison          Date:   May 1, 1985          **/
  810. /**                                                                  **/
  811. /**   Revised by: Arch D. Robison       Date:   Dec 2, 1985          **/
  812. /**                                                                  **/
  813. /**   Principal Investigators: Prof. R. H. Campbell                  **/
  814. /**                            Prof. W. J. Kubitz                    **/
  815. /**                                                                  **/
  816. /**                                                                  **/
  817. /**------------------------------------------------------------------**/
  818. /**   (C) Copyright 1987  University of Illinois Board of Trustees   **/
  819. /**                       All Rights Reserved.                       **/
  820. /**********************************************************************/
  821.  
  822. #include <stdio.h>
  823. #include "struct.h"
  824. #include "node.h"
  825. #include "umax.h"
  826.  
  827. /*
  828.  * Storage is divided into 4 classes:
  829.  *
  830.  *      free storage
  831.  *      list cells
  832.  *      strings
  833.  *      nodes descriptors 
  834.  *  
  835.  * Storage is allocated by pages.
  836.  */
  837.  
  838. /*
  839.  * Currently, the page table and descriptors don't do anything,
  840.  * so we define them out of existence.  Their intended use t is to allow
  841.  * reclamation of pages.
  842.  */
  843.  
  844. #define PAGETABLE 0
  845.  
  846. #if PAGETABLE
  847.  
  848. #define FreePage 0     /* Defines for PageType field of PageDesc structure */
  849. #define ListPage 1
  850. #define StrPage 2
  851. #define NodePage 3
  852.  
  853. typedef struct {
  854.    char PageType;       /* Type of page.  See defines above */
  855.    char *PageBase;      /* Base address of page             */
  856.    unsigned PageLen;    /* Length of page in bytes          */
  857. } PageDesc;
  858.  
  859. PageDesc PageTable [MaxPages];
  860.  
  861. int PageCount=0;
  862.  
  863. #endif /* PAGETABLE */
  864.  
  865. #if (OPSYS==UNIX || OPSYS==CTSS) 
  866. #define MaxPages 256
  867. #define SizeListPage (512 * sizeof (ListCell))
  868. #define SizeStrPage  (512 * sizeof (StrCell))
  869. #define SizeNodePage (256 * sizeof (NodeDesc))
  870. #endif                   
  871.  
  872. #if OPSYS==MSDOS 
  873. #define MaxPages 128
  874. #define SizeListPage (256 * sizeof (ListCell))
  875. #define SizeStrPage  (256 * sizeof (StrCell))
  876. #define SizeNodePage (128 * sizeof (NodeDesc))
  877. #endif
  878.  
  879. /*
  880.  * AllocListPage
  881.  *
  882.  * Returns pointer to list of cells in new list page.
  883.  * Each cell's value is initialized to NULL.
  884.  *
  885.  * NULL is returned if there are no more list pages available.
  886.  */
  887. ListPtr AllocListPage ()
  888.    {
  889. #if PAGETABLE
  890.       register PageDesc *PDp;
  891. #endif
  892.       register ListPtr P;
  893.       register int K;
  894.  
  895.       if (Debug & DebugAlloc) {
  896.          LineWait ();
  897.          printf ("AllocListPage ()\n");
  898.          LineSignal ();
  899.       }
  900. #if PAGETABLE
  901.       if (PageCount >= MaxPages) return NULL;
  902. #endif
  903.       P = (ListPtr) malloc (SizeListPage);
  904.       if (P == NULL) return NULL;
  905. #if PAGETABLE
  906.       PDp = PageTable + PageCount++;
  907.       PDp->PageType = ListPage;
  908.       PDp->PageLen = SizeListPage;
  909.       PDp->PageBase = (char *) P;
  910. #endif
  911.       P->Next = NULL;
  912.       for (K = SizeListPage/(sizeof (ListCell));;) {
  913.      P->LRef = LRefOne;
  914.      P->Val.Tag = BOTTOM;
  915.      if (!--K) break;
  916.      P++;
  917.      P->Next = P-1;
  918.       }
  919.       return P; 
  920.    }
  921.  
  922.  
  923. StrPtr AllocStrPage ()
  924.    {
  925. #if PAGETABLE
  926.       register PageDesc *PDp;
  927. #endif
  928.       register StrPtr P;
  929.       register int K;
  930.  
  931.       if (Debug & DebugAlloc) printf ("AllocStrPage ()\n");
  932. #if PAGETABLE
  933.       if (PageCount >= MaxPages) return NULL;
  934. #endif
  935.       P = (StrPtr) malloc (SizeStrPage);
  936.       if (P == NULL) return NULL;
  937. #if PAGETABLE
  938.       PDp = PageTable + PageCount++;
  939.       PDp->PageType = StrPage;
  940.       PDp->PageLen = SizeStrPage;
  941.       PDp->PageBase = (char *) P;
  942.       PDp = PageTable + PageCount++;
  943. #endif
  944.       P->StrNext = NULL;
  945.       for (K = SizeStrPage/(sizeof (StrCell));;) {
  946.      P->StrChar [0] = '\0';
  947.      P->SRef = 1;
  948.      if (!--K) break;
  949.      P++;
  950.      P->StrNext = P-1;
  951.       }
  952.       return P;
  953.    }
  954.  
  955. /*
  956.  * AllocNodePage
  957.  *
  958.  * Returns pointer to list of nodes in new node page.
  959.  */
  960. NodePtr AllocNodePage ()
  961.    {
  962. #if PAGETABLE
  963.       register PageDesc *PDp;
  964. #endif
  965.       register NodePtr P;
  966.       register int K;
  967.  
  968.       if (Debug & DebugAlloc) printf ("AllocNodePage ()\n");
  969. #if PAGETABLE
  970.       if (PageCount >= MaxPages) return NULL;
  971. #endif
  972.       P = (NodePtr) malloc (SizeNodePage);
  973.       if (P == NULL) return NULL;
  974. #if PAGETABLE
  975.       PDp = PageTable + PageCount++;
  976.       PDp->PageType = NodePage;
  977.       PDp->PageLen = SizeNodePage;
  978.       PDp->PageBase = (char *) P;
  979.       PDp = PageTable + PageCount++;
  980. #endif
  981.       P->NodeSib = NULL;
  982.       for (K = SizeNodePage/(sizeof (NodeDesc));;) {
  983.      P->NRef = 1;
  984.      if (!--K) break;
  985.      P++;
  986.      P->NodeSib = P-1;
  987.       };
  988.       return P; 
  989.    }
  990.  
  991. SHAR_EOF
  992. if test -f 'interp/apply.c'
  993. then
  994.     echo shar: over-writing existing file "'interp/apply.c'"
  995. fi
  996. cat << \SHAR_EOF > 'interp/apply.c'
  997.  
  998. /****** apply.c *******************************************************/
  999. /**                                                                  **/
  1000. /**                    University of Illinois                        **/
  1001. /**                                                                  **/
  1002. /**                Department of Computer Science                    **/
  1003. /**                                                                  **/
  1004. /**   Tool: IFP                         Version: 0.5                 **/
  1005. /**                                                                  **/
  1006. /**   Author:  Arch D. Robison          Date:   May 1, 1985          **/
  1007. /**                                                                  **/
  1008. /**   Revised by: Arch D. Robison       Date: July 29, 1986          **/
  1009. /**                                                                  **/
  1010. /**   Principal Investigators: Prof. R. H. Campbell                  **/
  1011. /**                            Prof. W. J. Kubitz                    **/
  1012. /**                                                                  **/
  1013. /**                                                                  **/
  1014. /**------------------------------------------------------------------**/
  1015. /**   (C) Copyright 1987  University of Illinois Board of Trustees   **/
  1016. /**                       All Rights Reserved.                       **/
  1017. /**********************************************************************/
  1018.  
  1019. #include <stdio.h>
  1020. #include "struct.h"
  1021. #include "node.h"
  1022. #include "stats.h"
  1023. #include "cache.h"
  1024.  
  1025. /*
  1026.  * ApplyCheck
  1027.  *
  1028.  * Check if a function definition is internally consistent
  1029.  */
  1030. boolean ApplyCheck (F)
  1031.    ObjectPtr F;
  1032.    {
  1033.       register ListPtr P;
  1034.       ObjectPtr D;
  1035.  
  1036.       switch (F->Tag) {
  1037.  
  1038.      case LIST:
  1039.  
  1040.         if ((P = F->List) == NULL) return 0;
  1041.         else {
  1042.  
  1043.            switch (P->Val.Tag) {
  1044.  
  1045.           case NODE: return 1;
  1046.  
  1047.           case LIST:   /* unlinked form */
  1048.              LinkPath (&P->Val,DEF);
  1049.              if (P->Val.Tag==NODE && P->Val.Node->NodeType==DEF) {
  1050.             D = &P->Val.Node->NodeData.NodeDef.DefCode;
  1051.             if (D->Code.CodeParam >= 0 &&
  1052.                 D->Code.CodeParam != ListLength (P->Next)) {
  1053.                DefError ((NodePtr) NULL,F,
  1054.                      "wrong number of parameters");
  1055.                return 0;
  1056.             }
  1057.              } else {
  1058.             DefError ((NodePtr) NULL,F,"not a PFO");
  1059.             return 0;
  1060.              }
  1061.              if (P->Val.Node == FormTable[NODE_Sel].FormNode)
  1062.             return P->Next->Val.Tag == INT;
  1063.              else if (P->Val.Node == FormTable[NODE_C].FormNode)
  1064.             return (P=P->Next) == NULL || P->Next == NULL;
  1065.              else if (P->Val.Node == FormTable[NODE_Out].FormNode)
  1066.             return 1;
  1067. #if FETCH
  1068.              else if (P->Val.Node == FormTable[NODE_Fetch].FormNode)
  1069.             return 1;
  1070. #endif
  1071.              else {
  1072.             while ((P=P->Next) != NULL)
  1073.                if (!ApplyCheck (&P->Val)) return 0;
  1074.             return 1;
  1075.              }
  1076.            
  1077.              case STRING: /* unlinked function */
  1078.             LinkPath (F,DEF);
  1079.             if (F->Tag != NODE || F->Node->NodeType != DEF) {
  1080.                DefError ((NodePtr) NULL,F,"not a definition");
  1081.                return 0;
  1082.             } else return 1;
  1083.  
  1084.              default:
  1085.             IntError ("ApplyCheck: illegal P->Val.Tag value");
  1086.             return 0;
  1087.           }
  1088.         }
  1089.  
  1090.      case NODE: return 1;   /* Linked function */
  1091. #if XDEF
  1092.      /* We should check that the string is a functional variable */
  1093.      case STRING: return 1;
  1094. #endif
  1095.      default:
  1096.         DefError ((NodePtr) NULL,F,"Invalid function/form definition");
  1097.         return 0;
  1098.       }
  1099.    }
  1100.  
  1101. /*----------------------------------------------------------------------*/
  1102.  
  1103. extern int TraceIndent;    /* Indentation level of trace  */
  1104. boolean Trace = 0;    /* Print function trace if set */
  1105. #define ENTER "ENTER> "
  1106. #define EXIT  "EXIT>  "
  1107.  
  1108. /*
  1109.  * ApplyFun points to node whenever a compiled function is being applied.
  1110.  * It is undefined at all other times.
  1111.  * It is undefined when running multithread.
  1112.  */ 
  1113. NodePtr ApplyFun;
  1114.  
  1115. /*
  1116.  * Apply
  1117.  *
  1118.  * Apply function *F to argument *InOut.  Put result in *InOut.
  1119.  * *F is linked if it was unlinked.
  1120.  *
  1121.  * There are five possible representations for the function:
  1122.  *
  1123.  *      <string ...>           Unlinked function
  1124.  *      node                   Linked function
  1125.  *      <<string ...> ...>     Unlinked PFO
  1126.  *      <node ...>             Linked PFO
  1127.  *    string               Functional variable
  1128.  *
  1129.  * Input
  1130.  *      *InOut = function argument
  1131.  *      *F = function
  1132.  *
  1133.  * Output
  1134.  *      *InOut = result of applying F to InOut
  1135.  *      *F = linked function
  1136.  *
  1137.  * Note: There is some weird casting for the linked form case.
  1138.  *       This is merely to avoid putting another pointer on the stack,
  1139.  *       which we want to avoid since that case is recursive.
  1140.  */
  1141. void Apply (InOut,F)
  1142.    ObjectPtr InOut;
  1143.    register ObjectPtr F;
  1144.    {
  1145.       extern void PrintTrace ();
  1146.       register ListPtr P;
  1147.  
  1148.       if (SysStop) {
  1149.      RepTag (InOut,BOTTOM);
  1150.      return;
  1151.       }
  1152.  
  1153. #if OPSYS==MSDOS
  1154.       StackCheck ();        /* Check for stack overflow or interrupt */
  1155. #endif
  1156.  
  1157.       Stat (StatApply (InOut));        /* Collect "apply()" statistics */
  1158.  
  1159.       switch (F->Tag) {
  1160.  
  1161.      case LIST:
  1162.  
  1163.         if ((P=F->List)->Val.Tag == NODE) {
  1164.  
  1165.            if (Trace) PrintTrace (F,InOut,ENTER);    /* linked PFO */
  1166.            TraceIndent++;
  1167.            P = (ListPtr) P->Val.Node;
  1168. #define Fn ((NodePtr) P)->NodeData.NodeDef.DefCode
  1169.            if (Fn.Tag == CODE)
  1170.           (*Fn.Code.CodePtr) (InOut,F->List->Next);
  1171. #undef Fn
  1172.            else
  1173.           DefError ((NodePtr) NULL,&F->List->Val,
  1174.                 "No compiled def for form");
  1175.            TraceIndent--;
  1176.            if (Trace || InOut->Tag==BOTTOM) PrintTrace (F,InOut,EXIT);
  1177.  
  1178.         } else if (P->Val.Tag == STRING) {         /* unlinked function */
  1179.  
  1180.            LinkPath (F,DEF);
  1181.            if (F->Tag==NODE && F->Node->NodeType==DEF)
  1182.           goto FunApply;
  1183.            else {
  1184.           DefError ((NodePtr) NULL,F,"not a definition");
  1185.           RepTag (InOut,BOTTOM);
  1186.            }
  1187.         } else {
  1188.            printf ("INTERNAL ERROR in Apply: illegal P->Val = ");
  1189.            OutObject (F);
  1190.            printf ("\n");
  1191.         }
  1192.         break;
  1193.  
  1194. FunApply:
  1195.      case NODE: {                    /* linked function */
  1196.         int SaveTrace;
  1197.  
  1198.         /* Evaluate linked function */
  1199.         P = (ListPtr) &(ApplyFun=F->Node)->NodeData.NodeDef;
  1200. #define D ((DefPtr) P)
  1201.         SaveTrace = Trace;
  1202.         Trace = D->DefFlags & TRACE;
  1203.         if (Trace|SaveTrace) PrintTrace (F,InOut,ENTER);
  1204.         TraceIndent++;
  1205.  
  1206.         if (D->DefCode.Tag != CODE) {
  1207.            if (D->DefCode.Tag == BOTTOM) ReadDef ((NodePtr) NULL,F);
  1208.            if (D->DefCode.Tag != BOTTOM) 
  1209.           CheckCache (&Cache[CacheUser],Apply (InOut,&D->DefCode))
  1210.            else {
  1211.           DefError ((NodePtr) NULL,F,"no source definition");
  1212.           RepTag (InOut,BOTTOM);
  1213.            }
  1214.         } else 
  1215.            CheckCache (&Cache[CachePrim],
  1216.                (*D->DefCode.Code.CodePtr) 
  1217.                (InOut,D->DefCode.Code.CodeParam));
  1218. #undef D
  1219.         TraceIndent--;
  1220.         if (Trace|SaveTrace || InOut->Tag == BOTTOM)
  1221.            PrintTrace (F,InOut,EXIT);
  1222.         Trace = SaveTrace;
  1223.  
  1224.         return;
  1225.      }
  1226. #if XDEF
  1227.      case STRING: {
  1228.         extern ListPtr Environment;
  1229.         P = Environment;
  1230.  
  1231.         for (P=Environment; P!=NULL; P=P->Next->Next)
  1232.            if (P->Val.String == F->String) {
  1233.           RepObject (InOut,&P->Next->Val);
  1234.           return;
  1235.            }
  1236.         IntError ("Apply: variable not in environment\n");
  1237.         return;
  1238.      }
  1239. #endif 
  1240.      default:
  1241.         DefError ((NodePtr) NULL,F,"Invalid function/form definition");
  1242.         RepTag (InOut,BOTTOM);
  1243.         return;
  1244.       }
  1245.    }
  1246.  
  1247.  
  1248. #if REFCHECK || UMAX
  1249. /*
  1250.  * RefCheck
  1251.  *
  1252.  * Check if all references required to apply function *F are defined and
  1253.  * resolved.
  1254.  *
  1255.  * *F is linked if it was unlinked.
  1256.  *
  1257.  * See function 'apply' above for the function representations
  1258.  *
  1259.  * Input
  1260.  *      Caller = &node of calling function, NULL for top level
  1261.  *      *F = function
  1262.  *
  1263.  * Output
  1264.  *      *F = linked function
  1265.  *    result = 1 iff all references resolved, 0 otherwise.
  1266.  *
  1267.  * Note: There is some weird casting for the linked form case.
  1268.  *       This is merely to avoid putting another pointer on the stack,
  1269.  *       which we want to avoid since that case is recursive.
  1270.  */
  1271. boolean RefCheck (Caller,F)
  1272.    NodePtr Caller;
  1273.    register ObjectPtr F;
  1274.    {
  1275.       register ListPtr P;
  1276.  
  1277.       if (SysStop) return 0;
  1278.  
  1279. #if OPSYS==MSDOS
  1280.       StackCheck ();
  1281. #endif
  1282.  
  1283.       switch (F->Tag) {
  1284.  
  1285.      case LIST:
  1286.         P = F->List;
  1287.         if (P == NULL) {
  1288.            IntError ("RefCheck: empty list");
  1289.            return 0;
  1290.  
  1291.         } else {
  1292.  
  1293.            switch (P->Val.Tag) {
  1294.  
  1295.           case LIST:   /* unlinked form */
  1296.              LinkPath (&P->Val,DEF);
  1297.              if (P->Val.Tag!=NODE || P->Val.Node->NodeType!=DEF) {
  1298.             DefError (Caller,&P->Val,"not a form");
  1299.             return 0;
  1300.              } /* else drop down to case NODE */
  1301.  
  1302.           case NODE: {  /* linked form */
  1303.  
  1304.              register NodePtr Fn;
  1305.  
  1306.              if ((Fn = P->Val.Node) == NULL) {
  1307.             IntError ("RefCheck: empty NodePtr");
  1308.             return 0;
  1309.              } else if (Fn->NodeData.NodeDef.DefCode.Tag != CODE) {
  1310.             DefError (Caller,&F->List->Val,
  1311.                  "No compiled def for form");
  1312.             return 0;    
  1313.              } else {
  1314.                 int OK = 1;
  1315.                 FormEntry *T;
  1316.                   for (T=FormTable; T<ArrayEnd(FormTable); T++) 
  1317.                 if (T->FormNode == Fn) break;
  1318.                 switch (T-FormTable) {
  1319.                case NODE_Comp:
  1320.                case NODE_Cons:
  1321.                case NODE_Each:
  1322.                case NODE_Filter:
  1323.                case NODE_If:
  1324.                case NODE_RInsert:
  1325.                case NODE_While:
  1326.                   for (P = F->List; (P=P->Next) != NULL; )
  1327.                      OK &= RefCheck (Caller,&P->Val);
  1328.                 }
  1329.                 return OK;
  1330.              }
  1331.           }
  1332.  
  1333.           case STRING: /* unlinked function */
  1334.              LinkPath (F,DEF);
  1335.              if (F->Tag != NODE || F->Node->NodeType != DEF) {
  1336.             DefError (Caller,F,"Not a function");
  1337.             return 0;
  1338.              } else break; /* down to case NODE */
  1339.            
  1340.           default:
  1341.              IntError ("Apply: illegal P->Val.Tag value");
  1342.              return 0;
  1343.            }
  1344.         }
  1345.  
  1346.      case NODE: {
  1347.         /* Evaluate linked function */
  1348.  
  1349.         boolean OK=1;
  1350.  
  1351.         P = (ListPtr) &F->Node->NodeData.NodeDef;
  1352. #define D ((DefPtr) P)
  1353.  
  1354.         if (D->DefCode.Tag != CODE) {
  1355.            if (!(D->DefFlags & RESOLVED)) {
  1356.           D->DefFlags |= RESOLVED;
  1357.           if (D->DefCode.Tag == BOTTOM) ReadDef (Caller,F);
  1358.           if (D->DefCode.Tag != BOTTOM)
  1359.              OK = RefCheck (F->Node,&D->DefCode);
  1360.           else {
  1361.              DefError (Caller,F,"no source definition");
  1362.              OK = 0;
  1363.           }
  1364.           D->DefFlags &= ~RESOLVED;
  1365.            }
  1366.         }
  1367. #undef D
  1368.         return OK;
  1369.      }
  1370.  
  1371.      default:
  1372.         DefError (Caller,F,"Invalid function/form definition");
  1373.         return 0;
  1374.       }
  1375.    }
  1376. #endif /* REFCHECK */
  1377.  
  1378. /******************************* end of apply.c *******************************/
  1379.  
  1380. SHAR_EOF
  1381. if test -f 'interp/binio.c'
  1382. then
  1383.     echo shar: over-writing existing file "'interp/binio.c'"
  1384. fi
  1385. cat << \SHAR_EOF > 'interp/binio.c'
  1386.  
  1387. /****** binio.c *******************************************************/
  1388. /**                                                                  **/
  1389. /**                    University of Illinois                        **/
  1390. /**                                                                  **/
  1391. /**                Department of Computer Science                    **/
  1392. /**                                                                  **/
  1393. /**   Tool: IFP                         Version: 0.5                 **/
  1394. /**                                                                  **/
  1395. /**   Author:  Arch D. Robison          Date:  May 12, 1986          **/
  1396. /**                                                                  **/
  1397. /**   Revised by: Arch D. Robison       Date: June 20, 1986          **/
  1398. /**                                                                  **/
  1399. /**   Principal Investigators: Prof. R. H. Campbell                  **/
  1400. /**                            Prof. W. J. Kubitz                    **/
  1401. /**                                                                  **/
  1402. /**                                                                  **/
  1403. /**------------------------------------------------------------------**/
  1404. /**   (C) Copyright 1987  University of Illinois Board of Trustees   **/
  1405. /**                       All Rights Reserved.                       **/
  1406. /**********************************************************************/
  1407.  
  1408.  
  1409. /******************************* end of binio.c *******************************/
  1410.  
  1411. SHAR_EOF
  1412. #    End of shell archive
  1413. exit 0
  1414.  
  1415. -- 
  1416.  
  1417. Rich $alz            "Anger is an energy"
  1418. Cronus Project, BBN Labs    rsalz@pineapple.bbn.com
  1419. Moderator, comp.sources.unix    sources@uunet.uu.net
  1420.